home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / class.c < prev    next >
C/C++ Source or Header  |  1992-10-06  |  43KB  |  1,627 lines
  1. /* ******************************************************************** */
  2. /*  class.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* classes                                                    */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: class.c,v 1.11 1992/03/14 14:33:48 pab Exp $
  9.  *
  10.  * $Log: class.c,v $
  11.  * Revision 1.11  1992/03/14  14:33:48  pab
  12.  * side efects return values
  13.  *
  14.  * Revision 1.10  1992/02/27  15:46:57  pab
  15.  * bytecode + error changes
  16.  *
  17.  * Revision 1.9  1992/01/29  13:39:10  pab
  18.  * Fixed gc bug
  19.  *
  20.  * Revision 1.8  1992/01/22  13:29:49  pab
  21.  * Fixed GC bug
  22.  *
  23.  * Revision 1.7  1992/01/17  22:28:06  pab
  24.  * Removed defstruct + defclass 'cos
  25.  * no one used them
  26.  *
  27.  * Revision 1.6  1992/01/09  22:28:46  pab
  28.  * Fixed for low tag ints
  29.  *
  30.  * Revision 1.5  1992/01/05  22:47:57  pab
  31.  * Minor bug fixes, plus BSD version
  32.  *
  33.  * Revision 1.4  1991/12/22  15:13:56  pab
  34.  * Xmas revision
  35.  *
  36.  * Revision 1.3  1991/11/15  13:44:31  pab
  37.  * copyalloc rev 0.01
  38.  *
  39.  * Revision 1.2  1991/09/11  12:07:05  pab
  40.  * 11/9/91 First Alpha release of modified system
  41.  *
  42.  * Revision 1.1  1991/08/12  16:49:30  pab
  43.  * Initial revision
  44.  *
  45.  * Revision 1.10  1991/06/17  19:05:23  pab
  46.  * altered set_assoc to eval properly.
  47.  *
  48.  * Revision 1.8  1991/02/13  18:18:53  kjp
  49.  * Pass.
  50.  *
  51.  */
  52.  
  53. #define KJPDBG(x) 
  54. #define INOUT(x)
  55. #define CLASSBUG(x) /* fprintf(stderr,"CLASSBUG:");x;fflush(stderr) */
  56.  
  57. /*
  58.  * Change Log:
  59.  *   Version 1, June 1989
  60.  *   Version N ( N >> 1 ), November 1989
  61.  */
  62.  
  63. #include <stdio.h>
  64. #include "defs.h"
  65. #include "structs.h"
  66.  
  67. #include "funcalls.h"
  68.  
  69. #include "global.h"
  70. #include "error.h"
  71.  
  72. #include "class.h"
  73. #include "vectors.h" 
  74. #include "table.h"   
  75. #include "bootstrap.h"
  76. #include "slots.h"
  77. #include "ngenerics.h"
  78. #include "modules.h"
  79. #include "modboot.h"
  80. #include "symboot.h"
  81. #include "garbage.h"
  82.  
  83. #define CLASSES_ENTRIES 61
  84. MODULE Module_classes;
  85. LispObject Module_classes_values[CLASSES_ENTRIES];
  86.  
  87. #define is_class(c) (typeof(c) == TYPE_CLASS)
  88. #define MYCONS(a,b)   EUCALL_2(Fn_cons,a,b)
  89.  
  90. extern LispObject Basic_Structure;
  91. extern LispObject Primitive_Class;
  92.  
  93. extern void set_anon_associate(LispObject*,LispObject,LispObject);
  94.  
  95. /* Internal symbols... */
  96.  
  97. static LispObject sym_direct_superclasses;
  98. static LispObject sym_direct_slot_descriptions;
  99. static LispObject sym_metaclass_hypotheses;
  100.  
  101. static LispObject sym_slot_class;
  102. static LispObject sym_slot_initargs;
  103.  
  104. static LispObject sym_predicate;
  105.  
  106. /* Functions... */
  107.  
  108. LispObject Fn_make_predicate(LispObject*);
  109.  
  110. /*
  111.  
  112.  * These are the class object accessor functions.
  113.  * At level-1 or above, most of these must be generic but at level-0 
  114.  * it is unnecesary
  115.  *
  116.  * All of the below assumes single inheritance - must change any piece
  117.  * of generic code referencing CLASS.superclass
  118.  
  119.  */
  120.  
  121. EUFUN_1( Fn_classp, class)
  122. {
  123.   LispObject Fn_subclassp(LispObject*);
  124.   RETURN_EUCALL(EUCALL_2(Fn_subclassp,classof(class),Standard_Class)); 
  125. }
  126. EUFUN_CLOSE
  127.  
  128. EUFUN_1( Fn_class_of, object)
  129. {
  130.   return(classof(object));
  131. }
  132. EUFUN_CLOSE
  133.  
  134. EUFUN_2( Fn_subclassp, sub, class)
  135. {
  136.   LispObject walker;
  137.  
  138.   if (sub == nil) return(nil);
  139.   if (sub == class) return(sub); /* Used to say lisptrue which is wrong */
  140.  
  141.   walker = sub->CLASS.superclasses;
  142.   while(is_cons(walker)) {
  143.     STACK_TMP(CDR(walker));
  144.     if (EUCALL_2(Fn_subclassp,CAR(walker),ARG_1(stackbase)) != nil)
  145.       return(ARG_0(stackbase));
  146.     else
  147.       UNSTACK_TMP(walker);
  148.   }
  149.  
  150.   return(nil);
  151. }
  152. EUFUN_CLOSE
  153.  
  154. EUFUN_1( Fn_class_name, class)
  155. {
  156.   if (EUCALL_2(Fn_subclassp,classof(class),Standard_Class) == nil)
  157.     CallError(stacktop,"class-name: not a class",ARG_0(stackbase),NONCONTINUABLE);
  158.  
  159.   return(ARG_0(stackbase)->CLASS.name);
  160. }
  161. EUFUN_CLOSE
  162.  
  163. EUFUN_1( Fn_class_precedence_list, class)
  164. {
  165.   if (typeof(class) != TYPE_CLASS)
  166.     CallError(stacktop,
  167.           "class-precedence-list: non class",class,NONCONTINUABLE);
  168.  
  169.   return(class->CLASS.precedence);
  170. }
  171. EUFUN_CLOSE
  172.  
  173. EUFUN_1( Fn_class_prototype, class)
  174. {
  175.   if (typeof(class) != TYPE_CLASS)
  176.     CallError(stacktop,"class-prototype: not a class",class,NONCONTINUABLE);
  177.   fprintf(stderr,"Class-prototype: No such function\n");
  178.  
  179.   return nil;
  180. }
  181. EUFUN_CLOSE
  182.  
  183. LispObject generic_compute_class_precedence_list;
  184.  
  185. EUFUN_1( Gf_compute_class_precedence_list, c)
  186. {
  187.   return(generic_apply_1(stacktop,generic_compute_class_precedence_list,c));
  188. }
  189. EUFUN_CLOSE
  190.  
  191. EUFUN_1( Md_compute_class_precedence_list_Class, class)
  192. {
  193.   LispObject walker,result;
  194.  
  195.   if (typeof(class) != TYPE_CLASS)
  196.     CallError(stacktop,
  197.           "compute-class-precedence-list: non class",class,NONCONTINUABLE);
  198.  
  199.   walker = class; result = nil;
  200.  
  201.   while (walker != nil) {
  202.     LispObject super, xx;
  203.  
  204.     STACK_TMP(walker);
  205.     STACK_TMP(result);
  206.     EUCALLSET_2(xx, Fn_cons, walker, nil);
  207.     UNSTACK_TMP(result);
  208.     EUCALLSET_2(result, Fn_nconc, result, xx);
  209.     UNSTACK_TMP(walker);
  210.     super = walker->CLASS.superclasses;
  211.     if (super == nil) 
  212.       walker = nil;
  213.     else if (is_cons(CDR(super)))
  214.       CallError(stacktop,"compute-class-precedence-list: mi class",class,
  215.         NONCONTINUABLE);
  216.     else
  217.       walker = CAR(super);
  218.   }
  219.  
  220.   return(result);
  221. }
  222. EUFUN_CLOSE
  223.  
  224. EUFUN_1( Fn_class_direct_superclasses, class)
  225. {
  226.   if (typeof(class) != TYPE_CLASS) 
  227.     CallError(stacktop,
  228.           "class-direct-superclasses: non class",class,NONCONTINUABLE);
  229.  
  230.   return(class->CLASS.superclasses);
  231. }
  232. EUFUN_CLOSE
  233.  
  234. EUFUN_1( Fn_class_direct_subclasses, class)
  235. {
  236.   if (typeof(class) != TYPE_CLASS) 
  237.     CallError(stacktop,
  238.           "class-direct-subclasses: non class",class,NONCONTINUABLE);
  239.  
  240.   return(class->CLASS.subclasses);
  241. }
  242. EUFUN_CLOSE
  243.  
  244. EUFUN_1( Fn_class_slot_descriptions, class)
  245. {
  246.   if (typeof(class) != TYPE_CLASS) 
  247.     CallError(stacktop,
  248.           "class-slot-descriptions: non class",class,NONCONTINUABLE);
  249.  
  250.   return(class->CLASS.slot_list);
  251. }
  252. EUFUN_CLOSE
  253.  
  254. EUFUN_1( Fn_class_direct_slot_descriptions, class)
  255. {
  256.   if (typeof(class) != TYPE_CLASS) 
  257.     CallError(stacktop,
  258.           "class-slot-descriptions: non class",class,NONCONTINUABLE);
  259.  
  260.   /* HACK !!! Wrong !! */
  261.  
  262.   return(class->CLASS.direct_slot_list);
  263. }
  264. EUFUN_CLOSE
  265.  
  266. /*
  267.  * Slot access protocol...
  268.  */
  269.  
  270. /* Generic slot-value-using-class */
  271.  
  272. LispObject generic_slot_value_using_class;
  273.  
  274. EUFUN_3( Gf_slot_value_using_class, c, o, p)
  275. {
  276.   return(generic_apply_3(stacktop,generic_slot_value_using_class,c,o,p));
  277. }
  278. EUFUN_CLOSE
  279.  
  280. EUFUN_3( Md_slot_value_using_class_Structure_Class, class, obj, pos)
  281. {
  282.   return(slotref(obj,intval(pos)));
  283. }
  284. EUFUN_CLOSE
  285.  
  286. EUFUN_3( Md_slot_value_using_class_Standard_Class, class, obj, pos)
  287. {
  288.   return(slotref(obj,intval(pos)));
  289. }
  290. EUFUN_CLOSE
  291.  
  292. LispObject generic_slot_value_using_class_setter;
  293.  
  294. /* You know, some people actually USE the value of these things :-( */
  295. EUFUN_4( Md_slot_value_using_class_setter_Structure_Class, class, obj, pos, val)
  296. {
  297.   LispObject tmp;
  298.   
  299.   slotrefupdate(obj,intval(pos),val);
  300.  
  301.   return val;
  302. }
  303. EUFUN_CLOSE
  304.  
  305. EUFUN_4( Md_slot_value_using_class_setter_Standard_Class, class, obj, pos, val)
  306. {
  307.   slotrefupdate(obj,intval(pos),val);
  308.  
  309.   return val;
  310. }
  311. EUFUN_CLOSE
  312.  
  313. LispObject generic_slot_value_using_slot_description;
  314.  
  315. EUFUN_2( Md_slot_value_using_slot_description_Local_Slot_Description,
  316.      obj, desc)
  317. {
  318.   LispObject xx;
  319.   EUCALLSET_1(xx, Fn_class_of, obj); /* CANNOT GC */
  320.   return(generic_apply_3(stacktop,generic_slot_value_using_class,
  321.              xx,
  322.              obj,
  323.              slot_desc_position(desc)));
  324. }
  325. EUFUN_CLOSE
  326.  
  327. LispObject generic_slot_value_using_slot_description_setter;
  328.  
  329. EUFUN_3( 
  330.   Md_slot_value_using_slot_description_setter_Local_Slot_Description,
  331.     obj, desc, val)
  332. {
  333.   LispObject xx;
  334.   EUCALLSET_1(xx, Fn_class_of, obj); /* CANNOT GC */
  335.   return(generic_apply_4(stacktop,generic_slot_value_using_class_setter,
  336.              xx, obj, slot_desc_position(desc), val));
  337. }
  338. EUFUN_CLOSE
  339.  
  340. LispObject generic_find_slot_description;
  341.  
  342. EUFUN_2( Gf_find_slot_description, c, n)
  343. {
  344.   return(generic_apply_2(stacktop,generic_find_slot_description,c,n));
  345. }
  346. EUFUN_CLOSE
  347.  
  348. EUFUN_2( Md_find_slot_description_Structure_Class, class, name)
  349. {
  350.   LispObject desc;
  351.  
  352.   EUCALLSET_2(desc, Fn_find_slot_description,class,name);
  353.  
  354.   if (desc == nil)
  355.     CallError(stacktop,
  356.           "find-slot-description: slot missing",
  357.           ARG_1(stackbase),NONCONTINUABLE);
  358.  
  359.   return(desc);
  360. }
  361. EUFUN_CLOSE
  362.  
  363.  
  364. EUFUN_2( Md_find_slot_description_Standard_Class, class, name)
  365. {
  366.   LispObject desc;
  367.  
  368.   EUCALLSET_2(desc, Fn_find_slot_description,class,name);
  369.  
  370.   if (desc == nil)
  371.     CallError(stacktop,"find-slot-description: slot missing",
  372.           ARG_1(stackbase),NONCONTINUABLE);
  373.  
  374.   return(desc);
  375. }
  376. EUFUN_CLOSE
  377.  
  378. EUFUN_2( Fn_slot_value, obj, slotname)
  379. {
  380.   LispObject desc;
  381.   LispObject xx;
  382.   
  383.   xx=classof(obj);
  384.   desc = generic_apply_2(stacktop,generic_find_slot_description,
  385.              xx, slotname);
  386.  
  387.   return(generic_apply_2(stacktop,generic_slot_value_using_slot_description,
  388.              ARG_0(stackbase),desc));
  389. }
  390. EUFUN_CLOSE
  391.  
  392.  
  393. EUFUN_3( Fn_slot_value_setter, obj, slotname, val)
  394. {
  395.   LispObject desc;
  396.   LispObject xx;
  397.   xx=classof(obj);
  398.  
  399.   desc = generic_apply_2(stacktop,generic_find_slot_description,
  400.              xx, slotname);
  401.  
  402.   return(generic_apply_3(stacktop,
  403.              generic_slot_value_using_slot_description_setter,
  404.              ARG_0(stackbase),desc,ARG_2(stackbase)));
  405. }
  406. EUFUN_CLOSE
  407.  
  408. /*
  409.  
  410.  * The inheritance protocol...
  411.  
  412.  */
  413.  
  414. EUFUN_3( Fn_add_superclasses, class, supers, slotsinitargs)
  415. {
  416.   LispObject walker,xx;
  417.  
  418.   /* fprintf(stderr,"add-supers: \n"); fflush(stderr); */
  419.  
  420.   if (typeof(class) != TYPE_CLASS)
  421.     CallError(stacktop,"add-superclasses: non class",class,NONCONTINUABLE);
  422.  
  423.   if (EUCALL_2(Fn_subclassp,classof(class),Standard_Class) == nil)
  424.     CallError(stacktop,"add-superclasses: non structure-class",
  425.           class,NONCONTINUABLE);
  426.  
  427.   /* Perform the 'add-subclass' calls on the supers - checks compatability */
  428.   /* Backtracking's a problem... */
  429.  
  430.   walker = supers;
  431.   while (is_cons(walker)) {
  432.     STACK_TMP(CDR(walker));
  433.     EUCALL_2(Fn_add_subclass,ARG_0(stackbase),CAR(walker));
  434.     UNSTACK_TMP(walker);
  435.   }
  436.  
  437.   /* Do precedence list... */
  438.  
  439.   class = ARG_0(stackbase);
  440.   EUCALLSET_1(xx,
  441.           Gf_compute_class_precedence_list,class); 
  442.   ARG_0(stackbase)->CLASS.precedence=xx;
  443.   class = ARG_0(stackbase); slotsinitargs=ARG_2(stackbase); 
  444.   EUCALL_2(Fn_collect_slots,class,slotsinitargs);
  445.   
  446.   return(ARG_0(stackbase));
  447. }
  448. EUFUN_CLOSE
  449.  
  450. EUFUN_2( Fn_add_subclass, class, super)
  451. {
  452.   extern LispObject Fn_nconc(LispObject*);
  453.   LispObject xx;
  454.  
  455. /* fprintf(stderr,"add-sub: \n"); fflush(stderr); */
  456.  
  457.   if (EUCALL_2(Fn_metaclass_compatibility,class,super) == nil)
  458.     CallError(stacktop,
  459.           "add-subclass: incompatible metaclasses",super,NONCONTINUABLE);
  460.  
  461.   /* Just mark the new class - change the existing ones later */
  462.  
  463.   super = ARG_1(stackbase);
  464.   EUCALLSET_2(xx,Fn_cons,super,nil);
  465.   class = ARG_0(stackbase);
  466.   EUCALLSET_2(xx,Fn_nconc,class->CLASS.superclasses,xx);
  467.   class = ARG_0(stackbase);
  468.   class->CLASS.superclasses = xx;
  469.   super = ARG_1(stackbase);
  470.   class->CLASS.local_count = super->CLASS.local_count;
  471.  
  472.   /* If we're all must have gone OK so now mark the existing class(es) */
  473.   /* Should be in a less haphazard order for multiple inheritance !!   */
  474.  
  475.   EUCALLSET_2(xx, Fn_cons, class, super->CLASS.subclasses);
  476.   super = ARG_1(stackbase);
  477.   super->CLASS.subclasses = xx;
  478.  
  479.   class = ARG_0(stackbase);
  480.   return(class);
  481. }
  482. EUFUN_CLOSE
  483.  
  484. EUFUN_2( Fn_metaclass_compatibility, class, super)
  485. {
  486.  
  487. /* fprintf(stderr,"compatability: \n"); fflush(stderr); */
  488.  
  489.   if (!is_class(class))
  490.     CallError(stacktop,
  491.           "metaclass-compatibility: non class",class,NONCONTINUABLE);
  492.  
  493.   if (!is_class(super))
  494.     CallError(stacktop,
  495.           "metaclass-compatibility: non class",super,NONCONTINUABLE);
  496.  
  497.   RETURN_EUCALL(EUCALL_2(Fn_subclassp,classof(class),classof(super)));
  498. }
  499. EUFUN_CLOSE
  500.  
  501. LispObject generic_add_slot_description;
  502.  
  503. EUFUN_2( Gf_add_slot_description, c, desc)
  504. {
  505.   return(generic_apply_2(stackbase,generic_add_slot_description,c,desc));
  506. }
  507. EUFUN_CLOSE
  508.  
  509. EUFUN_2( Md_add_slot_description_Class_Slot_Description, class, desc)
  510. {
  511.   LispObject xx;
  512.   if (class->CLASS.slot_table == nil) {
  513.     (ARG_0(stackbase))->CLASS.slot_table =
  514.       (LispObject) allocate_table(stacktop,Fn_eq);
  515.     class = ARG_0(stackbase);
  516.     desc=ARG_1(stackbase);
  517.   }
  518.  
  519.   EUCALL_3(tref_updator,class->CLASS.slot_table,
  520.               slot_desc_name(desc),desc);
  521.   class = ARG_0(stackbase);
  522.   desc = ARG_1(stackbase);
  523.   EUCALLSET_2(xx,Fn_cons,desc,class->CLASS.slot_list);
  524.   class = ARG_0(stackbase);
  525.   class->CLASS.slot_list = xx;
  526.  
  527.   return(class);
  528. }
  529. EUFUN_CLOSE
  530.  
  531. EUFUN_2( Md_add_slot_description_Class_Local_Slot_Description, class, desc)
  532. {
  533.   if (slot_desc_position(desc) == unbound)
  534.     {
  535.       int n;
  536.       n=(class->CLASS.local_count++);
  537.       slot_desc_position(desc) = allocate_integer(stacktop,n);
  538.       class=ARG_0(stackbase);
  539.       desc=ARG_1(stackbase);
  540.     }
  541.   RETURN_EUCALL(EUCALL_2(Md_add_slot_description_Class_Slot_Description,class,desc));
  542. }
  543. EUFUN_CLOSE
  544.  
  545. static LispObject find_superclass_slot_description(LispObject *stacktop,
  546.                            LispObject c,
  547.                            LispObject name)
  548. {
  549.   LispObject walker,desc;
  550.  
  551.   walker = c->CLASS.superclasses;
  552.   while (is_cons(walker)) {
  553.     STACK_TMP(CDR(walker));
  554.     STACK_TMP(name);
  555.     EUCALLSET_2(desc, Fn_find_slot_description,CAR(walker),name);
  556.     if (desc != nil) return(desc);
  557.     UNSTACK_TMP(name);
  558.     UNSTACK_TMP(walker);
  559.   }
  560.  
  561.   return(nil);
  562. }
  563.  
  564. static LispObject superclass_slot_descriptions(LispObject *stacktop,LispObject c)
  565. {
  566.   extern EUDECL( Fn_append);
  567.   LispObject all,walker;
  568.   
  569.   STACK_TMP(c);
  570.  
  571.   walker = c->CLASS.superclasses; all = nil;
  572.   while(is_cons(walker)) {
  573.     all = EUCALL_2(Fn_append,all,CAR(walker)->CLASS.slot_list);
  574.     walker = CDR(walker);
  575.   }
  576.   
  577.   UNSTACK_TMP(c);
  578.  
  579.   return(all);
  580. }
  581.  
  582. EUFUN_2( Fn_collect_slots, class, slots_initlist)
  583. {
  584.   LispObject allslots = nil;
  585.  
  586.   if (!is_class(class))
  587.     CallError(stacktop,"collect-slots: non class",class,NONCONTINUABLE);
  588.  
  589.   if (EUCALL_2(Fn_subclassp,classof(class),Standard_Class) == nil)
  590.     CallError(stacktop,"collect-slots: non class",class,NONCONTINUABLE);
  591.  
  592.   /* Collect the slots in such a way that for simple single 
  593.      inheritance, slot position is preserved...             */
  594.  
  595.   /* Bleargh!! Make the slots referenced in the initlist */
  596.  
  597.   while (is_cons(slots_initlist)) {
  598.     LispObject desc;
  599.     STACK_TMP(CDR(slots_initlist));
  600.     class=ARG_0(stackbase);
  601.     EUCALLSET_2(desc,Gf_make_slot_description,class,CAR(slots_initlist));
  602.     class=ARG_0(stackbase);
  603.     EUCALL_2(Gf_add_slot_description,class,desc);
  604.  
  605.     UNSTACK_TMP(slots_initlist);
  606.   }
  607.  
  608.   /* Now do any as yet uninherited... */
  609.  
  610.   allslots = superclass_slot_descriptions(stacktop,ARG_0(stackbase)/*class*/);
  611.   class=ARG_0(stackbase);
  612.   while (is_cons(allslots)) {
  613.     LispObject newdesc,oldesc;
  614.     
  615.     STACK_TMP(CDR(allslots));
  616.     oldesc = CAR(allslots);
  617.     STACK_TMP(oldesc);
  618.     EUCALLSET_2(newdesc,Fn_find_slot_description,
  619.         class,slot_desc_name(oldesc));
  620.     UNSTACK_TMP(oldesc);
  621.     if (newdesc == nil) {
  622.       EUCALLSET_3(newdesc, Gf_make_inherited_slot_description,
  623.           class,oldesc,nil);
  624.       class=ARG_0(stackbase);
  625.       EUCALL_2(Gf_add_slot_description,class,newdesc);
  626.     }
  627.     UNSTACK_TMP(allslots);
  628.     class=ARG_0(stackbase);
  629.   }
  630.  
  631.   return(class);
  632. }
  633. EUFUN_CLOSE
  634.  
  635. LispObject generic_make_slot_description;
  636.  
  637. EUFUN_2( Gf_make_slot_description, c, l)
  638. {
  639.   return(generic_apply_2(stacktop,generic_make_slot_description,c,l));
  640. }
  641. EUFUN_CLOSE
  642.  
  643. EUFUN_2( Md_make_slot_description_Class, class, plist)
  644. {
  645.   LispObject desc,slot_name,slot_class;
  646.   LispObject ret,xx;
  647.  
  648.   /* Search the initargs for specified... else default */
  649.  
  650.   slot_name = search_keylist(stacktop,plist,sym_name);
  651.   if (slot_name == unbound)
  652.     CallError(stacktop,"make-slot-description: slot name missing",plist,NONCONTINUABLE);
  653.   
  654.   STACK_TMP(slot_name);
  655.   desc = find_superclass_slot_description(stacktop,class,slot_name);
  656.   if (desc != nil) {
  657.     class=ARG_0(stackbase);
  658.     plist=ARG_1(stackbase);
  659.     RETURN_EUCALL(EUCALL_3(Gf_make_inherited_slot_description,class
  660.                ,desc,plist));
  661.   }
  662.   UNSTACK_TMP(slot_name);
  663.   plist=ARG_1(stackbase);
  664.   slot_class = search_keylist(stacktop,plist,sym_slot_class);
  665.  
  666.   if (slot_class == unbound) 
  667.     CallError(stacktop,"make-slot-description: missing slot class ",
  668.           plist,NONCONTINUABLE);
  669.   /* Generate the position as necessary */
  670.  
  671.   if (EUCALL_2(Fn_subclassp,slot_class,Slot_Description) == nil)
  672.     CallError(stacktop,"make-slot-description: invalid slot class",
  673.           slot_class,NONCONTINUABLE);
  674.  
  675.   /* Something of a hack but still... */
  676.  
  677.   EUCALLSET_2(ret,Gf_make_instance,slot_class,plist);
  678.   class=ARG_0(stackbase);
  679.   STACK_TMP(ret);
  680.   xx=MYCONS(ret,class->CLASS.direct_slot_list);
  681.   UNSTACK_TMP(ret);
  682.   class=ARG_0(stackbase);
  683.   class->CLASS.direct_slot_list = xx;
  684.  
  685.   return(ret);
  686. }
  687. EUFUN_CLOSE
  688.  
  689. LispObject generic_make_inherited_slot_description;
  690.  
  691. EUFUN_3( Gf_make_inherited_slot_description, c, d, l)
  692. {
  693.   return(generic_apply_3(stacktop,generic_make_inherited_slot_description,c,d,l));
  694. }
  695. EUFUN_CLOSE
  696.  
  697. EUFUN_3( Md_make_inherited_slot_description_Class_Slot_Description, class, oldesc, plist)
  698. {
  699.   extern LispObject generic_allocate_instance;
  700.   LispObject slot_class;
  701.   LispObject newdesc;
  702.  
  703.   IGNORE(class); /* Strange but true... */
  704.  
  705.   slot_class = classof(oldesc);
  706.  
  707.   newdesc = generic_apply_2(stacktop,generic_allocate_instance,slot_class,nil);
  708.   EUCALLSET_3(newdesc, Fn_inherit_slot_details,
  709.           newdesc,/*oldesc*/ARG_1(stackbase),/*plist*/ARG_2(stackbase));
  710.  
  711.   return(newdesc);
  712. }
  713. EUFUN_CLOSE
  714.  
  715. EUFUN_3( Fn_inherit_slot_details, newdesc, oldesc, plist)
  716. {
  717.   LispObject modifier;
  718.  
  719.   /* Should be generic I suppose */
  720.  
  721.   /* For local slot descriptions */
  722.  
  723.   if (EUCALL_2(Fn_subclassp,classof(newdesc),Slot_Description) == nil)
  724.     CallError(stacktop,"inherit-slot-details: non local slot description",
  725.           newdesc,NONCONTINUABLE);
  726.  
  727.   if (EUCALL_2(Fn_subclassp,classof(oldesc),Slot_Description) == nil)
  728.     CallError(stacktop,"inherit-slot-details: non local slot description",
  729.           oldesc,NONCONTINUABLE);
  730.  
  731.   /* All local - all cool... */
  732.  
  733.   /* Inherit as is - modify as necessary */
  734.  
  735.   /* Merge initargs... */
  736.  
  737.   slot_desc_initargs(newdesc) = slot_desc_initargs(oldesc);
  738.   modifier = search_keylist(stacktop,plist,sym_initargs);
  739.   if (modifier != unbound) {
  740.     if (slot_desc_initargs(oldesc) == unbound)
  741.       slot_desc_initargs(newdesc) = modifier;
  742.     else
  743.       EUCALLSET_2(slot_desc_initargs(newdesc),
  744.           Fn_nconc,modifier,slot_desc_initargs(newdesc));
  745.   }
  746.     
  747.   /* Merge initforms... */
  748.  
  749.   slot_desc_initform(newdesc) = slot_desc_initform(oldesc);
  750.   modifier = search_keylist(stacktop,plist,sym_initform);
  751.   if (modifier != unbound) slot_desc_initform(newdesc) = modifier;
  752.  
  753.   /* Just take name and position direct at level-0 */
  754.   
  755.   slot_desc_name(newdesc)     = slot_desc_name(oldesc);
  756.   slot_desc_position(newdesc) = slot_desc_position(oldesc);
  757.   slot_desc_mutable(newdesc)  = slot_desc_mutable(oldesc);
  758.   
  759.   return(newdesc);
  760. }
  761. EUFUN_CLOSE
  762.  
  763. /*
  764.  
  765.  * Instance generation... 
  766.  
  767.  */
  768.  
  769. /* GENERIC FUNCTION 'allocate_instance' */
  770.  
  771. LispObject generic_allocate_instance;
  772.  
  773. /* Standard-Class */
  774. EUFUN_2( Md_allocate_instance_1, class, initlist)
  775. {
  776.   LispObject new;
  777.  
  778.   IGNORE(initlist);
  779.  
  780.   if (EUCALL_2(Fn_subclassp,class,Standard_Class) != nil) {
  781.     new = (LispObject) allocate_class(stacktop,class);
  782.     STACK_TMP(new);
  783.     new->CLASS.slot_table = (LispObject) allocate_table(stacktop,Fn_eq);
  784.     UNSTACK_TMP(new);
  785.   }
  786.   else {
  787.     new = (LispObject) allocate_instance(stacktop,class);
  788.   }
  789.  
  790.   return(new);
  791. }
  792. EUFUN_CLOSE
  793.  
  794. /* Structure-Class */
  795. EUFUN_2( Md_allocate_instance_2, class, initlist)
  796. {
  797.   LispObject inst;
  798.  
  799.   inst = (LispObject) allocate_instance(stacktop,class);
  800.  
  801.   class=ARG_0(stackbase);
  802.   {
  803.     int i;
  804.     for(i=0; i<class->CLASS.local_count; i++)
  805.       slotref(inst,i) = unbound;
  806.   }
  807.  
  808.   return(inst);
  809. }
  810. EUFUN_CLOSE
  811.  
  812. /* Slot_Description_Class */
  813. EUFUN_2( Md_allocate_instance_3, class, initlist)
  814. {
  815.   LispObject inst;
  816.   
  817.   inst = (LispObject) allocate_instance(stacktop,class);
  818.  
  819.   slot_desc_mutable(inst) = lisptrue;
  820.  
  821.   {
  822.     int i;
  823.     for(i=0; i<class->CLASS.local_count; i++)
  824.       slotref(inst,i) = unbound;
  825.   }
  826.  
  827.   return(inst);
  828. }
  829. EUFUN_CLOSE
  830.  
  831. extern LispObject Condition_Class;
  832.  
  833. /* Condition-Class */
  834. EUFUN_2( Md_allocate_instance_4, class, initlist)
  835. {
  836.   LispObject cond;
  837.  
  838.   cond = (LispObject) allocate_instance(stacktop,class);
  839.  
  840.   {
  841.     int i;
  842.     for(i=0; i<class->CLASS.local_count; i++)
  843.       slotref(cond,i) = unbound;
  844.   }
  845.   return(cond);
  846. }
  847. EUFUN_CLOSE
  848.  
  849. /* Primitive classes */
  850. EUFUN_2( Md_allocate_instance_Primitive_Class, c, l)
  851. {
  852.   CallError(stacktop,"allocate-instance: can't allocate primitive",c,NONCONTINUABLE);
  853.   return(nil);
  854. }
  855. EUFUN_CLOSE
  856.  
  857. EUFUN_3( Fn_fill_slot, desc, obj, initlist)
  858. {
  859.   LispObject initargs,key,value = unbound;
  860.  
  861.   if (EUCALL_2(Fn_subclassp,classof(desc),Slot_Description) == nil) 
  862.     CallError(stacktop,"fill-slot: invalid slot description",desc,NONCONTINUABLE);
  863.  
  864.   initargs = slot_desc_initargs(desc);
  865.   while(is_cons(initargs)) {
  866.     key = CAR(initargs); initargs = CDR(initargs);
  867.     value = search_keylist(stacktop,initlist,key);
  868.     if (value != unbound) break;
  869.   }
  870.  
  871.   if (value != unbound) {
  872.     (void) generic_apply_3(stacktop,generic_slot_value_using_slot_description_setter,
  873.                obj,desc,value);
  874.   }
  875.   else {
  876.     if (slot_desc_initform(desc) != unbound) {
  877.       LispObject xx;
  878.       extern LispObject Fn_apply(LispObject*);
  879.  
  880.       EUCALLSET_2(xx, Fn_apply,slot_desc_initform(desc),nil);
  881.       (void) generic_apply_3(stacktop,generic_slot_value_using_slot_description_setter,
  882.                  ARG_1(stackbase)/*obj*/,ARG_0(stackbase)/*desc*/,
  883.                  xx);
  884.                              /* Should be other... */
  885.  
  886.     }
  887.   }
  888.   
  889.   return(ARG_1(stackbase));
  890. }
  891. EUFUN_CLOSE
  892.  
  893.  
  894. /* GENERIC FUNCTION 'initialize_instance' */  
  895.  
  896. LispObject generic_initialize_instance;
  897.  
  898. /* Object */
  899. EUFUN_2( Md_initialize_instance_1, obj, initlist)
  900. {
  901.   LispObject class = classof(obj);
  902.   LispObject local_slots;
  903.  
  904.   CLASSBUG(fprintf(stderr,"init-inst: structure\n"));
  905.  
  906.   /* OK - initialize strategy is - take each local slot in turn.
  907.                                    get it's instance description.
  908.                    if it has initargs, search the initlist.
  909.                    failing that use initform.
  910.                    failing THAT leave unbound. */
  911.  
  912.   /* Should get a more efficient table stepper one day but ... */
  913.  
  914.   EUCALLSET_1(local_slots, Fn_class_slot_descriptions,class); 
  915.  
  916.   /* Tryin' it with all slots */
  917.  
  918.   while (local_slots != nil) {
  919.     LispObject desc = CAR(local_slots);
  920.     
  921.     CLASSBUG(fprintf(stderr,"init-inst: structure, filling...\n"));
  922.     STACK_TMP(CDR(local_slots));
  923.     obj=ARG_0(stackbase); initlist=ARG_1(stackbase);
  924.     EUCALL_3(Fn_fill_slot,desc,obj,initlist);
  925.     UNSTACK_TMP(local_slots);
  926.   }
  927.  
  928.   obj=ARG_0(stackbase);
  929.   return(obj);
  930. }
  931. EUFUN_CLOSE
  932.  
  933. /* Standard-Class */
  934. EUFUN_2( Md_initialize_instance_2, obj, initlist)
  935. {
  936.   LispObject name,superclass,slot_descriptions;
  937.  
  938.   obj=EUCALL_2(Md_initialize_instance_1,obj,initlist); /* Other slots... */
  939.   initlist=ARG_1(stackbase);
  940.   name = search_keylist(stacktop,initlist,sym_name);
  941.   if (name == unbound) name = sym_anonymous_class;
  942.   superclass = search_keylist(stacktop,initlist,sym_direct_superclasses);
  943.  
  944.   ARG_0(stackbase)=obj;
  945.   if (superclass == unbound) 
  946.     {
  947.       STACK_TMP(name);
  948.       STACK_TMP(superclass);
  949.       EUCALLSET_2(superclass, Fn_cons,Object,nil);
  950.       UNSTACK_TMP(superclass);
  951.       UNSTACK_TMP(name);
  952.     }    
  953.  
  954.   if (!is_cons(superclass))
  955.     CallError(stacktop,"initialize-instance: bad superclasses",
  956.           superclass,NONCONTINUABLE);
  957.   obj=ARG_0(stackbase); initlist=ARG_1(stackbase);
  958.   slot_descriptions = search_keylist(stacktop,initlist,sym_direct_slot_descriptions);
  959.   if (slot_descriptions == unbound) slot_descriptions = nil;
  960.  
  961.   /* Do inheritance & initialization */
  962.  
  963.   obj->CLASS.name = name;
  964.  
  965.   /* These don't do what they're supposed to */
  966.   /* In fact currently they just add the parent/children info */
  967.  
  968.   EUCALL_3(Fn_add_superclasses,obj,superclass,slot_descriptions);
  969.   obj=ARG_0(stackbase);
  970.  
  971.   return(obj);
  972.  
  973. }
  974. EUFUN_CLOSE
  975.  
  976. /* Slot_Description */
  977. EUFUN_2( Md_initialize_instance_3, obj, initlist)
  978. {
  979.   LispObject name,position,initargs,initform,mutable;
  980.  
  981.   name = search_keylist(stacktop,initlist,sym_name);
  982.   if (name == unbound)
  983.     CallError(stacktop,"initialize-instance: no name for slot description",
  984.           unbound,NONCONTINUABLE);
  985.  
  986.   position = search_keylist(stacktop,initlist,sym_position);
  987.   initargs = search_keylist(stacktop,initlist,sym_initargs);
  988.   initform = search_keylist(stacktop,initlist,sym_initform);
  989.   mutable  = search_keylist(stacktop,initlist,sym_mutable);
  990.  
  991.   /* Should verify... */
  992.  
  993.   slot_desc_name(obj) = name;
  994.   slot_desc_position(obj) = position;
  995.   slot_desc_initargs(obj) = initargs;
  996.   slot_desc_initform(obj) = initform;
  997.   slot_desc_mutable(obj) = (mutable == nil ? nil : lisptrue);
  998.  
  999.   RETURN_EUCALL(EUCALL_2(Md_initialize_instance_1,obj,initlist));
  1000. }
  1001. EUFUN_CLOSE
  1002.  
  1003. extern LispObject Default_Condition;
  1004.  
  1005. /* Default-Condition */
  1006. EUFUN_2( Md_initialize_instance_4, obj, initlist)
  1007. {
  1008.   LispObject message,value;
  1009.  
  1010.   message = search_keylist(stacktop,initlist,sym_message);
  1011.   if (message == unbound) message = nil;
  1012.   value = search_keylist(stacktop,initlist,sym_error_value);
  1013.   condition_message(obj) = message;
  1014.   condition_error_value(obj) = value;
  1015.  
  1016.   RETURN_EUCALL(EUCALL_2(Md_initialize_instance_1,obj,initlist));
  1017. }
  1018. EUFUN_CLOSE
  1019.  
  1020. /* A would-be generic... */
  1021.  
  1022. EUFUN_2( Gf_make_instance, class, initargs)
  1023. {
  1024.   LispObject obj;
  1025.  
  1026.   obj = generic_apply_2(stacktop,generic_allocate_instance,class,initargs);
  1027.   initargs=ARG_1(stackbase);
  1028.   obj = generic_apply_2(stackbase,generic_initialize_instance,obj,initargs);
  1029.  
  1030.   return(obj);
  1031. }
  1032. EUFUN_CLOSE
  1033.  
  1034. /*
  1035.  
  1036.  * The defstruct stuff...
  1037.  
  1038.  */
  1039.  
  1040. /* Keylist utilities... */
  1041.  
  1042. /* Searches through alternating symbol/value slot option lists for opname */
  1043.   
  1044. LispObject search_option(LispObject opname,LispObject oplist)
  1045. {
  1046.   if (oplist == nil) return(unbound);
  1047.   if (CAR(oplist) == opname) return(CAR(CDR(oplist)));
  1048.   return(search_option(opname,CDR(CDR(oplist))));
  1049. }
  1050.  
  1051. /* Does the same thing more robustly... */
  1052.  
  1053. LispObject search_keylist(LispObject *stacktop,LispObject list,LispObject key)
  1054. {
  1055.   int i=0;
  1056.   LispObject ptr;
  1057.  
  1058.   if (list != nil && !is_cons(list))
  1059.     CallError(stacktop,"invalid key list",list,NONCONTINUABLE);
  1060.   
  1061.   ptr=list;
  1062.   while (ptr!=nil)
  1063.     { i++;
  1064.       ptr=CDR(ptr);
  1065.     }
  1066.  
  1067.   if (i%2 != 0)
  1068.     CallError(stacktop,"unbalanced initlist",list,NONCONTINUABLE);
  1069.  
  1070.  
  1071.   while(list != nil) {
  1072.     LispObject lkey = CAR(list);
  1073.     LispObject lval = CAR(CDR(list));
  1074.     
  1075.     if (key == lkey) return(lval);
  1076.  
  1077.     list = CDR(CDR(list));
  1078.   }
  1079.  
  1080.   return(unbound);
  1081. }
  1082.  
  1083.  
  1084. extern LispObject canonical_slot_initargs(LispObject*);
  1085.  
  1086. /* Sets up the canonical form and verifies */
  1087.  
  1088. EUFUN_3( canonical_slot_initargs, mod, env, slotspec)
  1089. {
  1090.   return nil;
  1091. }
  1092. EUFUN_CLOSE
  1093.  
  1094. /*
  1095.  
  1096.  * Various class / slot utilities...
  1097.  
  1098.  */
  1099.  
  1100. EUFUN_1( Fn_local_slots, class)
  1101. {
  1102.   LispObject i_d;
  1103.  
  1104.   i_d = class->CLASS.slot_table; 
  1105.  
  1106.   if (i_d == nil) return(nil); /* No slots at all */
  1107.  
  1108.   if (is_table(i_d)) {
  1109.     LispObject local = nil,all;
  1110.  
  1111.     EUCALLSET_1(all, Fn_table_parameters,i_d);
  1112.     while (all!=nil) {
  1113.       STACK_TMP(CDR(all));
  1114.       if (EUCALL_2(Fn_subclassp,classof(CAR(all)),Local_Slot_Description) != nil) {
  1115.     local = MYCONS(CAR(all),local);
  1116.       }
  1117.       UNSTACK_TMP(all);
  1118.     }
  1119.  
  1120.     return(local);
  1121.   }
  1122.  
  1123.   CallError(stacktop,"as yet unimplemented instance_description type",class,
  1124.         NONCONTINUABLE);
  1125.  
  1126.   return(nil);  /* Dummy */
  1127. }
  1128. EUFUN_CLOSE
  1129.  
  1130. EUFUN_2( Fn_mutable_slot_p, object, slot )
  1131. {
  1132.   STUB("mutable-slot-p");
  1133.  
  1134.   return(lisptrue);
  1135. }
  1136. EUFUN_CLOSE
  1137.  
  1138. EUFUN_2( Fn_slot_exists_p, object, slotname )
  1139. {
  1140.   LispObject class = classof(object);
  1141.  
  1142.   /* May have to genericise it later */
  1143.  
  1144.   if ( TREF(CLASS_DESCS(class),slotname) != nil ) {
  1145.     return(slotname);
  1146.   }
  1147.   else {
  1148.     return(nil);
  1149.   }
  1150. }
  1151. EUFUN_CLOSE
  1152.  
  1153. EUFUN_2( Fn_slot_bound_p, object, slotname)
  1154. {
  1155.   
  1156.   if (EUCALL_2(Fn_slot_exists_p,object,slotname) == nil) {
  1157.     signal_message(stacktop,SLOT_MISSING,"slot-bound-p",slotname);
  1158. /*    CallError(stacktop,"slot-missing",slotname,NONCONTINUABLE); */
  1159.   }
  1160.  
  1161.   if (EUCALL_2(Fn_slot_value,object,slotname) == unbound) {
  1162.     return(nil);
  1163.   }
  1164.   else {
  1165.     return(slotname);
  1166.   }
  1167. }
  1168. EUFUN_CLOSE
  1169.  
  1170. EUFUN_1( Fn_slot_description_readers, desc)
  1171. {
  1172.   STUB("slot-description-readers");
  1173.  
  1174.   return(nil);
  1175. }
  1176. EUFUN_CLOSE
  1177.  
  1178. EUFUN_1( Fn_slot_description_writers, desc)
  1179. {
  1180.   STUB("slot-description-writers");
  1181.  
  1182.   return(nil);
  1183. }
  1184. EUFUN_CLOSE
  1185.  
  1186. /*
  1187.  
  1188.  * Constructor / accessor generation.
  1189.  *
  1190.  * These are set out in the C equivalent of...
  1191.  *
  1192.  * (defun make-reader (class slot-name)
  1193.  *   (let ((pos (slot-description-position 
  1194.  *                (find-slot-description class slot-name))))
  1195.  *     (lambda (obj) (slot-value-using-class class obj pos))))
  1196.  *
  1197.  * ... or some such. All accessors have their home in the same module.
  1198.  *               (That module being 'classes' for now)
  1199.  
  1200.  */
  1201.  
  1202. static EUFUN_2( constructor_template, env, initlist)
  1203. {
  1204.   RETURN_EUCALL(EUCALL_2(Gf_make_instance,symbol_ref(stacktop,NULL,env,sym_class),initlist));
  1205. }
  1206. EUFUN_CLOSE
  1207.  
  1208. EUFUN_1( Fn_make_constructor, class)
  1209. {
  1210.   return(make_anonymous_module_env_function_1(stacktop,
  1211.                           (LispObject) &Module_classes,
  1212.                           constructor_template,
  1213.                           -1,sym_class,class));
  1214. }
  1215. EUFUN_CLOSE
  1216.  
  1217. /* Template for structure-class metainstances... */
  1218.  
  1219. EUFUN_2( structure_reader_template, env, obj)
  1220. {
  1221.   if (EUCALL_2(Fn_subclassp,classof(obj),
  1222.            symbol_ref(stacktop,NULL,env,sym_class)) == nil)
  1223.     CallError(stacktop,"wrong class of object for reader",obj,NONCONTINUABLE);
  1224.  
  1225.   return(slotref(obj,intval(symbol_ref(stacktop,NULL,env,sym_position))));
  1226. }
  1227. EUFUN_CLOSE
  1228.  
  1229. /* Anything template */
  1230.  
  1231. EUFUN_2( reader_template, env, obj)
  1232. {    
  1233.   RETURN_EUCALL(EUCALL_2(Fn_slot_value,obj,((Env)env)->value));
  1234. }
  1235. EUFUN_CLOSE
  1236.  
  1237. EUFUN_2( Fn_make_reader, class, slot)
  1238. {
  1239.   LispObject desc,pos;
  1240.  
  1241.   if (!is_class(class))
  1242.     CallError(stacktop,"make-reader: non class",class,NONCONTINUABLE);
  1243.  
  1244.   if (classof(class) == Structure_Class) {
  1245.  
  1246.     EUCALLSET_2(desc, Fn_find_slot_description,class,slot);
  1247.     EUCALLSET_1(pos, Fn_slot_description_position,desc);
  1248.  
  1249.     if (pos == unbound)
  1250.       CallError(stacktop,"make-reader: cannot-make-reader",pos,NONCONTINUABLE);
  1251.  
  1252.     return(make_anonymous_module_env_function_2(stacktop,
  1253.                         (LispObject) &Module_classes,
  1254.                         structure_reader_template,
  1255.                         1,
  1256.                         sym_position,pos,
  1257.                         sym_class,class));
  1258.   }
  1259.  
  1260.   /* Most general - hacking slot-value */
  1261.  
  1262.   return(make_anonymous_module_env_function_1(stacktop,
  1263.                           (LispObject) &Module_classes,
  1264.                           reader_template,1,
  1265.                           sym_nil,slot));
  1266. }
  1267. EUFUN_CLOSE
  1268.  
  1269. EUFUN_3( structure_writer_template, env, obj, val)
  1270. {
  1271.   LispObject tmp;
  1272.  
  1273.   if (EUCALL_2(Fn_subclassp,classof(obj),
  1274.            symbol_ref(stacktop,NULL,env,sym_class)) == nil)
  1275.     CallError(stacktop,"wrong class of object for writer",obj,
  1276.           NONCONTINUABLE);
  1277.   
  1278.   slotrefupdate(obj,intval(symbol_ref(stacktop,NULL,env,sym_position)),val);
  1279.   
  1280.   return val;
  1281. }
  1282. EUFUN_CLOSE
  1283.  
  1284. EUFUN_3( writer_template, env, obj, val)
  1285. {
  1286.   RETURN_EUCALL(EUCALL_3(Fn_slot_value_setter,obj,((Env)env)->value,val));
  1287. }
  1288. EUFUN_CLOSE
  1289.  
  1290. EUFUN_2( Fn_make_writer, class, slot)
  1291. {
  1292.   LispObject desc, pos;
  1293.  
  1294.   if (!is_class(class))
  1295.     CallError(stacktop,"make-writer: non class",class,NONCONTINUABLE);
  1296.  
  1297.   if (classof(class) == Structure_Class) {
  1298.  
  1299.     EUCALLSET_2(desc, Fn_find_slot_description,class,slot);
  1300.     EUCALLSET_1(pos, Fn_slot_description_position,desc);
  1301.  
  1302.     if (pos == unbound)
  1303.       CallError(stacktop,"make-writer: cannot-make-writer",pos,NONCONTINUABLE);
  1304.  
  1305.     return(make_anonymous_module_env_function_2(stacktop,(LispObject) &Module_classes,
  1306.                         structure_writer_template,
  1307.                         2,
  1308.                         sym_position,pos,
  1309.                         sym_class,class));
  1310.   }
  1311.  
  1312.   return(make_anonymous_module_env_function_1(stacktop,
  1313.                           (LispObject) &Module_classes,
  1314.                           writer_template,2,
  1315.                           sym_nil,slot));
  1316. }
  1317. EUFUN_CLOSE
  1318.  
  1319. static EUFUN_2( predicate_template, env, obj)
  1320. {
  1321.   return((EUCALL_2(Fn_subclassp,classof(obj),((Env)env)->value) == nil ?
  1322.       nil : lisptrue));
  1323. }
  1324. EUFUN_CLOSE
  1325.  
  1326. EUFUN_1( Fn_make_predicate, class)
  1327. {
  1328.   LispObject p;
  1329.  
  1330.   if (!is_class(class))
  1331.     CallError(stacktop,
  1332.           "make-predicate: non-class supplied",class,NONCONTINUABLE);
  1333.  
  1334.   p = make_anonymous_module_env_function_1(stacktop,
  1335.                        (LispObject) &Module_classes,
  1336.                        predicate_template,1,nil,class);
  1337.  
  1338.   return(p);
  1339. }
  1340. EUFUN_CLOSE
  1341.   
  1342. /* 
  1343.  * Chris Burdorf hacks...
  1344.  */
  1345.  
  1346. #define is_instance(obj) (typeof(obj) == TYPE_INSTANCE)
  1347.  
  1348. EUFUN_1( Fn_instance_slots, inst)
  1349. {
  1350.   if (!is_instance(inst))
  1351.     CallError(stacktop,
  1352.           "instance-slots: not a simple instance",inst,NONCONTINUABLE);
  1353. #ifdef naff /* Mon Jul 22 19:05:48 1991 */
  1354. /**/
  1355. /**/  return(inst->INSTANCE.slots);
  1356. #endif /* naff Mon Jul 22 19:05:48 1991 */
  1357.   printf("Instance slots: unimplementable function\n");
  1358.   return nil;
  1359. }
  1360. EUFUN_CLOSE
  1361.  
  1362. EUFUN_2( Fn_instance_slots_setter, inst, val)
  1363. {
  1364.   if (!is_instance(inst))
  1365.     CallError(stacktop,
  1366.           "instance-slots: not a simple instance",inst,NONCONTINUABLE);
  1367.  
  1368.   printf("Instance slots setter: unimplementable function\n");
  1369.   return nil;
  1370. #ifdef naff /* Mon Jul 22 19:06:24 1991 */
  1371. /**/  inst->INSTANCE.slots = val;
  1372. /**/  return(inst);
  1373. #endif /* naff Mon Jul 22 19:06:24 1991 */
  1374. }
  1375. EUFUN_CLOSE
  1376.  
  1377. EUFUN_2( Fn_class_of_setter, obj, class)
  1378. {
  1379.   printf("Setter of class-of called. Your program may now crash\n");
  1380.   if (!is_instance(obj))
  1381.     CallError(stacktop,
  1382.           "(setter class-of): not a simple instance",obj,NONCONTINUABLE);
  1383.  
  1384.   if (!is_class(class))
  1385.     CallError(stacktop,"(setter class-of): non class",class,NONCONTINUABLE);
  1386.  
  1387.   lval_classof(obj) = class;
  1388.  
  1389.   return(obj);
  1390. }
  1391. EUFUN_CLOSE
  1392.  
  1393. /* *************************************************************** */
  1394. /* Initialisation of this module (should be seperate...)           */
  1395. /* *************************************************************** */
  1396.  
  1397. /* Class name module stuff... */
  1398.  
  1399. #define CLASS_NAMES_ENTRIES 111 /* Too many */
  1400. MODULE Module_class_names;
  1401. LispObject Module_class_names_values[CLASS_NAMES_ENTRIES];
  1402.  
  1403. void register_class_names(LispObject *stacktop,LispObject c)
  1404. {
  1405.   LispObject sub;
  1406.  
  1407.   make_module_entry_using_symbol(stacktop,c->CLASS.name,c);
  1408.  
  1409.   sub = c->CLASS.subclasses;
  1410.  
  1411.   while (sub != nil) {
  1412.     STACK_TMP(CDR(sub));
  1413.     register_class_names(stacktop,CAR(sub));
  1414.     UNSTACK_TMP(sub);
  1415.   }
  1416. }
  1417.  
  1418. /* *************************************************************** */
  1419. /* Initialisation of this module                                   */
  1420. /* *************************************************************** */
  1421.  
  1422. #define SET_ASSOC(a,b) \
  1423.   { LispObject tmp,tmp2; \
  1424.     STACK_TMP(a); \
  1425.     tmp2=b; \
  1426.     UNSTACK_TMP(tmp); \
  1427.     set_anon_associate(stacktop,tmp,tmp2); \
  1428.   }
  1429.  
  1430. void initialise_classes(LispObject *stacktop)
  1431. {
  1432.   extern void set_anon_associate(LispObject*,LispObject,LispObject);
  1433.   /* Internal symbols... */
  1434.  
  1435.   sym_direct_superclasses     =get_symbol(stacktop,"direct-superclasses");
  1436.   add_root(&sym_direct_superclasses);
  1437.   sym_direct_slot_descriptions=get_symbol(stacktop,"direct-slot-descriptions");
  1438.   add_root(&sym_direct_slot_descriptions);
  1439.   sym_metaclass_hypotheses    = get_symbol(stacktop,"metaclass-hypotheses");
  1440.   add_root(&sym_metaclass_hypotheses);
  1441.   sym_slot_class = get_symbol(stacktop,"slot-class");
  1442.   add_root(&sym_slot_class);
  1443.   sym_slot_initargs = get_symbol(stacktop,"slot-initargs");
  1444.   add_root(&sym_slot_initargs);
  1445.   sym_predicate = get_symbol(stacktop,"predicate");
  1446.   add_root(&sym_predicate);
  1447.   /* The class names module */
  1448.  
  1449.   open_module(stacktop,
  1450.           &Module_class_names,Module_class_names_values,
  1451.           "class-names",CLASS_NAMES_ENTRIES);
  1452.   register_class_names(stacktop,Object);
  1453.   close_module();
  1454.  
  1455.   /* Class operations */
  1456.  
  1457.   open_module(stacktop,
  1458.           &Module_classes,Module_classes_values,
  1459.           "classes",CLASSES_ENTRIES);
  1460.  
  1461.   /* Class object accessors... */
  1462.  
  1463.   (void) make_module_function(stacktop,"classp",Fn_classp,1);
  1464.   SET_ASSOC(make_module_function(stacktop,"class-of",Fn_class_of,1),
  1465.         make_unexported_module_function(stacktop,"class-of-setter",
  1466.                         Fn_class_of_setter,2));
  1467.   (void) make_module_function(stacktop,"subclassp",Fn_subclassp,2);
  1468.   (void) make_module_function(stacktop,"class-name",Fn_class_name,1);
  1469.   (void) make_module_function(stacktop,"class-prototype",Fn_class_prototype,1);
  1470.   (void) make_module_function(stacktop,"class-precedence-list",
  1471.                   Fn_class_precedence_list,1);
  1472.   (void) make_module_function(stacktop,"class-direct-superclasses",
  1473.                   Fn_class_direct_superclasses,1);
  1474.   (void) make_module_function(stacktop,"class-direct-subclasses",
  1475.                   Fn_class_direct_subclasses,1);
  1476.   (void) make_module_function(stacktop,"class-slot-descriptions",
  1477.                   Fn_class_slot_descriptions,1);
  1478.   (void) make_module_function(stacktop,"class-direct-slot-descriptions",
  1479.                   Fn_class_direct_slot_descriptions,1);
  1480.  
  1481.   /* Inheritance... */
  1482.   generic_compute_class_precedence_list
  1483.     = make_wrapped_module_generic(stacktop,"compute-class-precedence-list",1,
  1484.                   Gf_compute_class_precedence_list);
  1485.   add_root(&generic_compute_class_precedence_list);
  1486.   (void) make_module_function(stacktop,"generic_compute_class_precedence_list,Standard_Class",
  1487.                   Md_compute_class_precedence_list_Class,
  1488.                   1);
  1489.   
  1490.   /* Slot access protocol... */
  1491.  
  1492.   generic_slot_value_using_class 
  1493.     = make_module_generic(stacktop,"slot-value-using-class",3);
  1494.   add_root(&generic_slot_value_using_class);
  1495.   make_module_function(stacktop,"generic_slot_value_using_class,Structure_Class",
  1496.                Md_slot_value_using_class_Structure_Class,
  1497.                3);
  1498.   make_module_function(stacktop,"generic_slot_value_using_class,Standard_Class",
  1499.                Md_slot_value_using_class_Standard_Class,
  1500.                3);
  1501.  
  1502.   generic_slot_value_using_class_setter 
  1503.     = make_module_generic(stacktop,"(setter slot-value-using-class)",4);
  1504.   add_root(&generic_slot_value_using_class_setter);
  1505.   make_module_function(stacktop,"generic_slot_value_using_class_setter,StructureClass",
  1506.                Md_slot_value_using_class_setter_Structure_Class,
  1507.                4);
  1508.   make_module_function(stacktop,"generic_slot_value_using_class_setter,Standard_Class",
  1509.                Md_slot_value_using_class_setter_Standard_Class,
  1510.                4);
  1511.   SET_ASSOC(generic_slot_value_using_class,
  1512.         generic_slot_value_using_class_setter);
  1513.  
  1514.   generic_slot_value_using_slot_description 
  1515.     = make_module_generic(stacktop,"slot-value-using-slot-description",2);
  1516.   add_root(&generic_slot_value_using_slot_description);
  1517.   make_module_function(stacktop,"generic_slot_value_using_slot_description,Object,Local_Slot_Description",
  1518.                Md_slot_value_using_slot_description_Local_Slot_Description,
  1519.                2);
  1520.  
  1521.   generic_slot_value_using_slot_description_setter 
  1522.     = make_module_generic(stacktop,
  1523.               "(setter slot-value-using-slot-description)",3);
  1524.   add_root(&generic_slot_value_using_slot_description_setter);
  1525.   make_module_function(stacktop,
  1526.                "generic_slot_value_using_slot_description_setter,Object,Local_Slot_Description",
  1527.                Md_slot_value_using_slot_description_setter_Local_Slot_Description,
  1528.                3);
  1529.   SET_ASSOC(generic_slot_value_using_slot_description,
  1530.         generic_slot_value_using_slot_description_setter);
  1531.       
  1532.   generic_find_slot_description 
  1533.     = make_module_generic(stacktop,"find-slot-description",2);
  1534.   add_root(&generic_find_slot_description);
  1535.   make_module_function(stacktop,"generic_find_slot_description,Structure_Class",
  1536.         Md_find_slot_description_Structure_Class,
  1537.         2);
  1538.   make_module_function(stacktop,"generic_find_slot_description,Standard_Class",
  1539.         Md_find_slot_description_Standard_Class,
  1540.         2);
  1541.  
  1542.  
  1543.   SET_ASSOC(make_module_function(stacktop,"slot-value",
  1544.                  Fn_slot_value,2),
  1545.         make_module_function(stacktop,"slot-value-setter",
  1546.                  Fn_slot_value_setter,3));
  1547.  
  1548.   /* Inheritance... */
  1549.  
  1550.   (void) make_module_function(stacktop,"add-superclasses",Fn_add_superclasses,3);
  1551.   (void) make_module_function(stacktop,"add-subclass",Fn_add_subclass,2);
  1552.   (void) make_module_function(stacktop,"collect-slots",Fn_collect_slots,2);
  1553.   
  1554.   generic_make_slot_description 
  1555.     = make_module_generic(stacktop,"make-slot-description",2);
  1556.   add_root(&generic_make_slot_description);
  1557.   (void) make_module_function(stacktop,"generic_make_slot_description,Standard_Class",
  1558.                   Md_make_slot_description_Class,2);
  1559.  
  1560.   generic_make_inherited_slot_description 
  1561.     = make_module_generic(stacktop,"make-inherited-slot-description",3);
  1562.   add_root(&generic_make_inherited_slot_description);
  1563.   (void) make_module_function(stacktop,
  1564.                   "generic_make_inherited_slot_description,Standard_Class,Slot_Description",
  1565.                   Md_make_inherited_slot_description_Class_Slot_Description,3
  1566.                   );
  1567.  
  1568.   generic_add_slot_description = make_module_generic(stacktop,
  1569.                              "add-slot-description",2);
  1570.   add_root(&generic_add_slot_description);
  1571.   (void) make_module_function(stacktop,"generic_add_slot_description,StandardClass,SlotDescription",
  1572.                   Md_add_slot_description_Class_Slot_Description,2
  1573.                   );
  1574.   (void) 
  1575.     make_module_function(stacktop,"generic_add_slot_description,StandardClass,LocalSlotDescription",
  1576.              Md_add_slot_description_Class_Local_Slot_Description,2
  1577.              );
  1578.  
  1579.   /* GF initialisation */
  1580.  
  1581.   generic_allocate_instance = make_module_generic(stacktop,
  1582.                           "allocate-instance",2);
  1583.   add_root(&generic_allocate_instance);
  1584.   make_module_function(stacktop,"generic_allocate_instance,StandardClass",
  1585.                Md_allocate_instance_1,2);
  1586.   make_module_function(stacktop,"generic_allocate_instance,StructureClass",
  1587.                Md_allocate_instance_2,2);
  1588.   make_module_function(stacktop,"generic_allocate_instance,Slot_Description_Class",
  1589.                Md_allocate_instance_3,2);
  1590.   make_module_function(stacktop,"generic_allocate_instance,Condition_Class",
  1591.                Md_allocate_instance_4,2);
  1592.   make_module_function(stacktop,"generic_allocate_instance,Primitive_Class",
  1593.                Md_allocate_instance_Primitive_Class,
  1594.                2);
  1595.  
  1596.   generic_initialize_instance = make_module_generic(stacktop,
  1597.                             "initialize-instance",2);
  1598.   add_root(&generic_initialize_instance);
  1599.   make_module_function(stacktop,"generic_initialize_instance,Object",
  1600.                Md_initialize_instance_1,2);
  1601.   make_module_function(stacktop,"generic_initialize_instance,Standard_Class",
  1602.                Md_initialize_instance_2,2);
  1603.   make_module_function(stacktop,"generic_initialize_instance,Slot_Description",
  1604.                Md_initialize_instance_3,2);
  1605.   make_module_function(stacktop,"generic_initialize_instance,Default_Condition",
  1606.                Md_initialize_instance_4,2); 
  1607.  
  1608.   make_module_function(stacktop,"make-instance",Gf_make_instance,-2);
  1609.  
  1610.   make_module_function(stacktop,"make-constructor",Fn_make_constructor,1);
  1611.   make_module_function(stacktop,"make-reader",Fn_make_reader,2);
  1612.   make_module_function(stacktop,"make-writer",Fn_make_writer,2);
  1613.   make_module_function(stacktop,"make-predicate",Fn_make_predicate,1);
  1614.  
  1615.   SET_ASSOC(make_module_function(stacktop,"slots-of",
  1616.                  Fn_instance_slots,
  1617.                  1),
  1618.         make_unexported_module_function(stacktop,"instance-slots-setter",
  1619.                         Fn_instance_slots_setter,
  1620.                         2));
  1621.  
  1622.   initialise_slots(stacktop);
  1623.  
  1624.   close_module();
  1625. }
  1626.  
  1627.